# -*- mode: perl; -*-
use File::Basename;

my $bytesize = 64;
my %sym = (); # defined symbols
my %usym = (); # undefined symbols
my %constants = (); # constants =<W-Value>=,   word=>{[location1, location2]}
my $start = -1; # program entry
my $loc = 0; # location counter
my $ln = 0; # line number
my $endln = 0;
my %code = (); # {location,line-number,word}
my $nerr = 0;
my $charset = " ABCDEFGHI^JKLMNOPQR^^STUVWXYZ0123456789.,()+-*/=\$<>@;:'";

# OPNAME => [ OPCODE, DEFAULT-F]
my %optable = (
    NOP  => [ 0, 1], ADD  => [ 1, 5], FADD => [ 1, 6], SUB  => [ 2, 5],
    FSUB => [ 2, 6], MUL  => [ 3, 5], FMUL => [ 3, 6], DIV  => [ 4, 5],
    FDIV => [ 4, 6], NUM  => [ 5, 0], CHAR => [ 5, 1], HLT  => [ 5, 2],
    SLA  => [ 6, 0], SRA  => [ 6, 1], SLAX => [ 6, 2], SRAX => [ 6, 3],
    SLC  => [ 6, 4], SRC  => [ 6, 5], MOVE => [ 7, 1], LDA  => [ 8, 5],
    LD1  => [ 9, 5], LD2  => [10, 5], LD3  => [11, 5], LD4  => [12, 5],
    LD5  => [13, 5], LD6  => [14, 5], LDX  => [15, 5], LDAN => [16, 5],
    LD1N => [17, 5], LD2N => [18, 5], LD3N => [19, 5], LD4N => [20, 5],
    LD5N => [21, 5], LD6N => [22, 5], LDXN => [23, 5], STA  => [24, 5],
    ST1  => [25, 5], ST2  => [26, 5], ST3  => [27, 5], ST4  => [28, 5],
    ST5  => [29, 5], ST6  => [30, 5], STX  => [31, 5], STJ  => [32, 2],
    STZ  => [33, 5], JBUS => [34, 0], IOC  => [35, 0], IN   => [36, 0],
    OUT  => [37, 0], JRED => [38, 0], JMP  => [39, 0], JSJ  => [39, 1],
    JOV  => [39, 2], JNOV => [39, 3], JL   => [39, 4], JE   => [39, 5],
    JG   => [39, 6], JGE  => [39, 7], JNE  => [39, 8], JLE  => [39, 9],
    JAN  => [40, 0], JAZ  => [40, 1], JAP  => [40, 2], JANN => [40, 3],
    JANZ => [40, 4], JANP => [40, 5], J1N  => [41, 0], J1Z  => [41, 1],
    J1P  => [41, 2], J1NN => [41, 3], J1NZ => [41, 4], J1NP => [41, 5],
    J2N  => [42, 0], J2Z  => [42, 1], J2P  => [42, 2], J2NN => [42, 3],
    J2NZ => [42, 4], J2NP => [42, 5], J3N  => [43, 0], J3Z  => [43, 1],
    J3P  => [43, 2], J3NN => [43, 3], J3NZ => [43, 4], J3NP => [43, 5],
    J4N  => [44, 0], J4Z  => [44, 1], J4P  => [44, 2], J4NN => [44, 3],
    J4NZ => [44, 4], J4NP => [44, 5], J5N  => [45, 0], J5Z  => [45, 1],
    J5P  => [45, 2], J5NN => [45, 3], J5NZ => [45, 4], J5NP => [45, 5],
    J6N  => [46, 0], J6Z  => [46, 1], J6P  => [46, 2], J6NN => [46, 3],
    J6NZ => [46, 4], J6NP => [46, 5], JXN  => [47, 0], JXZ  => [47, 1],
    JXP  => [47, 2], JXNN => [47, 3], JXNZ => [47, 4], JXNP => [47, 5],
    INCA => [48, 0], DECA => [48, 1], ENTA => [48, 2], ENNA => [48, 3],
    INC1 => [49, 0], DEC1 => [49, 1], ENT1 => [49, 2], ENN1 => [49, 3],
    INC2 => [50, 0], DEC2 => [50, 1], ENT2 => [50, 2], ENN2 => [50, 3],
    INC3 => [51, 0], DEC3 => [51, 1], ENT3 => [51, 2], ENN3 => [51, 3],
    INC4 => [52, 0], DEC4 => [52, 1], ENT4 => [52, 2], ENN4 => [52, 3],
    INC5 => [53, 0], DEC5 => [53, 1], ENT5 => [53, 2], ENN5 => [53, 3],
    INC6 => [54, 0], DEC6 => [54, 1], ENT6 => [54, 2], ENN6 => [54, 3],
    INCX => [55, 0], DECX => [55, 1], ENTX => [55, 2], ENNX => [55, 3],
    CMPA => [56, 5], FCMP => [56, 6], CMP1 => [57, 5], CMP2 => [58, 5],
    CMP3 => [59, 5], CMP4 => [60, 5], CMP5 => [61, 5], CMP6 => [62, 5],
    CMPX => [63, 5]
);

my $srcfile = shift @ARGV;
usage() if !defined $srcfile;
open FILE, "<$srcfile" or die "Error open source file";
my @src = <FILE>;
close FILE;
my ($basename, $path, $type) = fileparse($srcfile, qr{\..*});
my $lstfile = $basename . ".lst";
my $crdfile = $basename . ".crd";

foreach (@src)
{
    $ln++;
    s/\s+$//;
    next if m/^\*/;
    next if m/^\s*$/;
    my $l = length($_) < 80 ? $_ . " " x (80 - length($_)) : $_;
    build_instruction(substr($l,0,10), substr($l,11,4), substr($l, 16));
    last if $endln > 0;
}

if ($nerr > 0)
{
    print STDERR sprintf "Total %d error%s found.\n", $nerr, $nerr > 1 ? "s" : "";
    exit(-1);
}

#generate list file
open LSTFILE, ">$lstfile" || die "Can not open $lstfile for write";
$ln = 0;
foreach (@src)
{
    $ln++;
    my $s = $_;
    my $loc = find_code($ln);

    if ($ln == $endln)
    {
        foreach (sort grep {%code->{$_}->{line-number} == -1} keys %code)
        {
            my $l = $_;
            printf LSTFILE "%04d: %s         ", $_, word_to_string(%code->{$l}->{word}, "CON");

            if (%code->{$l}->{type} =~ m/^USYM-(\w+)$/)
            {
                printf LSTFILE "%-10s CON  0\n", $1;
            }
            else
            {
                printf LSTFILE "           CON  %d\n", %code->{$l}->{word};
            }
        }
    }

    if (defined $loc)
    {
        my $w = %code->{$loc}->{word};
        my $t = %code->{$loc}->{type};
        printf LSTFILE "%04d: %s ", $loc, word_to_string($w, $t);
    }
    else
    {
        print  LSTFILE ' ' x 24;
    }
    printf LSTFILE "  %4d  ", $ln;
    print LSTFILE $s, "\n";
}
close LSTFILE;

#generate card file
open CRDFILE, ">$crdfile" || die "can not open $crdfile for write";

my @locs = sort {$a <=> $b} keys %code;
my @cardbuf = ();
while (@locs) {
    if (@cardbuf == 0) {
        push @cardbuf, shift @locs;
    } else {
        if ($cardbuf[0] == $locs[0]-1 && @cardbuf < 7) {
            unshift @cardbuf, shift @locs;
        } else {
            print CRDFILE gen_card(@cardbuf), "\n";
            @cardbuf = ();
            unshift @cardbuf, shift @locs;
        }
    }
}

if (@cardbuf != 0) 
{
    print CRDFILE gen_card(@cardbuf), "\n";
}

if ($start >= 0 && $start <= 3999) 
{
    print CRDFILE sprintf("TRANS0%04d\n", $start);
}

close CRDFILE;


exit($nerr == 0? 0 : -1);

sub gen_card 
{
    my @locs = @_;
    my $n = @locs;
    my $i = $n - 1;
    my $crd;
    
    if (%code->{$locs[$i]}->{type} eq 'OP') 
    {
        $crd = sprintf("CODE %d%04d", $n, $locs[$i]);
    } 
    else 
    {
        $crd = sprintf("DATA %d%04d", $n, $locs[$i]);
    }

    my @chars     = qw(0 1 2 3 4 5 6 7 8 9);
    my @neg_chars = (" ", "A", "B", "C", "D", "E", "F", "G", "H", "I");
    for (; $i >= 0; $i--) 
    {
        my $w = %code->{$locs[$i]}->{word};
        my $sign = signof($w);
        my $val = abs($w);
        my $tmp = "";
        for (my $j = 0; $j < 10; $j++) 
        {
            if ($j == 0 && $sign < 0) 
            {
                $tmp = @neg_chars[$val % 10] . $tmp;
            } 
            else 
            {
                $tmp = @chars[$val % 10] . $tmp;
            }
            $val = int($val/10);
        }
        $crd .= $tmp;
    }
    return $crd;
}

sub word_to_string
{
    my ($w,$t) = @_;
    my $sign = (signof($w) == -1 ? "- " : "+ ");
    my $str = "";
    $w = abs($w);
    my @b = ();
    for (1..5)
    {
        unshift @b, $w % $bytesize;
        $w = int($w/$bytesize);
    }

    if ($t eq "ALF" || $t eq "CON")
    {
        return $sign . sprintf(" %2d %2d %2d %2d %2d", 
                               $b[0], $b[1], $b[2], $b[3], $b[4]);
    }
    else
    {
        return $sign . sprintf("%6d %2d %2d %2d", 
                               $b[0]*$bytesize+$b[1], $b[2], $b[3], $b[4]);
    }
}

sub find_code
{
    my $ln = shift;
    foreach (keys %code)
    {
        if (%code->{$_}->{line-number} == $ln)
        {
            return $_;
        }
    }
    return undef;
}

sub build_instruction
{
    my ($label, $op, $operand) = @_;
    $label =~ s/\s+$//g;
    $op =~ s/\s+//g;
    my $opr = substr($operand, 0, index($operand, " "));
    my $tokenizer = make_tokenizer($opr);
    if ($op eq "EQU")
    {
        add_symbol($label, parse_w_value($tokenizer));
    }
    elsif ($op eq "ORIG")
    {
        add_symbol($label, $loc);
        $loc = parse_w_value($tokenizer);
    }
    elsif ($op eq "CON")
    {
        add_symbol($label, $loc);
        add_code("CON", $loc++, $ln, parse_w_value($tokenizer));
    }
    elsif ($op eq "ALF")
    {
        add_symbol($label, $loc);
        add_code("ALF", $loc++, $ln, chars_to_word(substr($operand, 0, 5)));
    }
    elsif ($op eq "END")
    {
	add_symbol($label, $loc + (scalar keys %constants) + (scalar keys %usym)
		                + (exists %usym->{$label} ? -1 : 0));
	alloc_data_space();
	$start = parse_w_value($tokenizer);
	$start = -1 if !defined $start;
	$endln = $ln;
    }
    elsif (exists %optable->{$op})
    {
        add_symbol($label, $loc);
        my ($c, $default_f) = @{%optable->{$op}};
        my ($a, $i, $f) = parse_operand($tokenizer);
        $f = $default_f if !defined $f;
        if ($i < 0 || $i >= 7)
        {
            error("invalid I-field: $i");
            $i = 0;
        }
        if ($f < 0 || $f >= $bytesize)
        {
            error("invalid F-field: $f");
            $f = 0;
        }
        my $sign = signof($a);
        if (abs($a) >= $bytesize ** 2)
        {
            error("A-field can not fit: $a");
            $a = 0;
        }
        $a = abs($a);
        my $w = $a * ($bytesize ** 3) + $i * ($bytesize ** 2) + $f * $bytesize + $c;
        add_code("OP", $loc++, $ln, $sign * $w);
    }
    else
    {
        error("undefined op \'$op\'");
    }
}

sub alloc_data_space
{
    foreach (sort keys %constants)
    {
        my $w = $_;
        my @locs = @{%constants->{$w}->{location}};
        foreach (@locs)
        {
            %code->{$_}->{word} = set_word(%code->{$_}->{word}, $loc, 0, 2);
        }
        add_code("CON", $loc, -1, $w);
        $loc++;
    }

    foreach (sort keys %usym)
    {
        my $label = $_;
        foreach (@{%usym->{$label}})
        {
            my $t = $_;
            %code->{$t}->{word} = set_word(%code->{$t}->{word}, $loc, 0, 2);
        }
        %sym->{$label} = $loc;
        add_code("USYM-$label", $loc, -1, 0);
        $loc++;
    }
}

sub error
{
    print STDERR "Line " , $ln, ": ", @_, "\n";
    $nerr++;
}

sub add_symbol
{
    my ($label, $value) = @_;
    return if $label =~ m/^\s*$/;
    if (exists %sym->{$label} && $label !~ m/^\dH$/)
    {
        error("symbol redefined \'$label\'");
        return;
    }
    %sym->{$label} = $value;
    $label =~ s/H/F/;
    if (exists %usym->{$label})
    {
        foreach (@{%usym->{$label}})
        {
            my $t = $_;
            %code->{$t}->{word} = set_word(%code->{$t}->{word}, $value, 0, 2);
        }
        delete %usym->{$label};
    }
}

sub add_code
{
    my ($type, $loc, $ln, $w) = @_;
    %code->{$loc} = {type=>$type, line-number=>$ln,word=>$w};
}

sub make_tokenizer
{
        my $src = shift;
        my @unget_tokens = ();
        return {
            next_token => sub {
                if (@unget_tokens > 0)
                {
                    my $tok = pop @unget_tokens;
                    return @{$tok};
                }
                # TODO: check integer not larger than 10 digits
                return ( 'INTEGER', $1 )  if $src =~ /\G(\d+)\b/gcx;
                return ( 'FORWARD-REF', $1 ) if $src =~ /\G(\dF)\b/gcx;
                return ( 'BACKWARD-REF', $1 ) if $src =~ /\G(\dB)\b/gcx;
                return ( exists %sym->{$1} ?'SYMBOL':'UNDEF-SYMBOL', $1 ) if $src =~ /\G(\w+)/gcx;
                return ( '+', $1 )        if $src =~ /\G(\+)/gcx;
                return ( '-', $1 )        if $src =~ /\G(\-)/gcx;
                return ( '*', $1 )        if $src =~ /\G(\*)/gcx;
                return ( ':', $1 )        if $src =~ /\G(\:)/gcx;
                return ( '//', $1 )       if $src =~ /\G(\/\/)/gcx;
                return ( '/', $1 )        if $src =~ /\G(\/)/gcx;
                return ( '(', $1 )        if $src =~ /\G(\()/gcx;
                return ( ')', $1 )        if $src =~ /\G(\))/gcx;
                return ( '=', $1 )        if $src =~ /\G(\=)/gcx;
                return ( ',', $1)         if $src =~ /\G(,)/gcx;
                return ( 'UNKOWN', $1 )   if $src =~ /\G(.)/gcx;
                return;
            },
            unget => sub {
                my ($a,$b) = @_;
                push @unget_tokens, [$a,$b];
            }
        };
}

sub set_word
{
    my ($w, $value, $l, $r) = @_;
    if ($l > $r || $l < 0 || $r < 0 || $r > 5)
    {
        error("invalid F field");
        return $w;
    }
    my $sign = ($l == 0 ? signof($value) : signof($w));
    $w = abs($w);
    return $w * $sign if $r == 0;
    $value = abs($value);
    $l = 1 if $l == 0;
    if ($value >= ($bytesize ** ($r - $l + 1)))
    {
        error("value $value not fit into $l:$r");
        return $w;
    }

    $value = $value * ($bytesize ** (5 - $r));
    $w = int($w / ($bytesize ** (6 - $l))) * ($bytesize ** (6 - $l))
        + $w % ($bytesize ** (5 - $r))
        + $value;

    return $w * $sign;
}

sub parse_w_value
{
    my $tokenizer = shift;
    my $w = 0;
    for (;;)
    {
        my $value = parse_expr($tokenizer);
        my $f = parse_fpart($tokenizer);
        my @token;
        if (defined $f)
        {
            $w = set_word($w, $value, int($f/8), int($f)%8);
            @token = $tokenizer->{next_token}();
        }
        else
        {
            $w = $value;
        }
        last if !defined @token || @token != 2;
        next if $token[0] eq ",";
        $tokenizer->{unget}(@token);
        last;
    }
    return $w;
}

sub parse_atom_expr
{
    my $tokenizer = shift;
    my @token = $tokenizer->{next_token}();
    my $w = 0;

    if (!defined @token 
        || ($token[0] ne "SYMBOL"
            && $token[0] ne "*"
            && $token[0] ne "INTEGER"
            && $token[0] ne "BACKWARD-REF"))
    {
        if (defined @token && $token[0] eq "UNDEF-SYMBOL"
            && $token[0] eq "FORWARD-REF")
        {
            error("undef-symbol/forward reference not allowed in expression");
        }
        else
        {
            error("expecting defined symbol or backward reference");
        }
        return $w;
    }

    if ($token[0] eq "INTEGER")
    {
        return $token[1];
    }
    elsif ($token[0] eq "*")
    {
        return $loc;
    }
    elsif ($token[1] =~ m/(\d)B/)
    {
        if (exists %sym->{$1 . "H"})
        {
            return $w = %sym->{$1 . "H"};
        }
        else
        {
            error($token[1] . " not found");
            return $w;
        }
    }
    else
    {
        if (exists %sym->{$token[1]})
        {
            return $w = %sym->{$token[1]};
        }
        else
        {
            error($token[1] . " not found");
            return $w;
        }
    }
}

sub do_binary_op 
{
    my ($op, $operand1, $operand2) = @_;
    return $operand1 + $operand2 if $op eq '+';
    return $operand1 - $operand2 if $op eq '-';
    return $operand1 * $operand2 if $op eq '*';
    return $operand1 * 8 + $operand2 if $op eq ':';
    return int($operand1 / $operand2) if $op eq '/';
    if ($op eq '//') {
        my $tmp = $bytesize ** 5;
        return int(($operand1 * $tmp) / $operand2);
    }
    error("bad op: '$op'");
    return 0;
}

sub binary_op 
{
    my $t = @_[0];
    return $t eq ':' || $t eq '+' || $t eq '-' || $t eq '*' || $t eq '/' || $t eq '//'; 
}

sub parse_expr
{
    my $tokenizer = shift;
    my @token = $tokenizer->{next_token}();
    my $w = 0;
    if (!defined @token || @token != 2)
    {
        error("invalid expr");
        return $w;
    }
    if ($token[0] eq "+")
    {
        $w = parse_atom_expr($tokenizer);
    }
    elsif ($token[0] eq "-")
    {
        $w = 0 - parse_atom_expr($tokenizer);
    }
    else
    {
        $tokenizer->{unget}(@token);
        $w = parse_atom_expr($tokenizer);
    }
    for(;;)
    {
        @token = $tokenizer->{next_token}();
        last if !defined @token || @token != 2;
        if (binary_op($token[0]))
        {
            my $t = parse_atom_expr($tokenizer);
            $w = do_binary_op($token[0], $w, $t);
        }
        else
        {
            $tokenizer->{unget}(@token);
            last;
        }
    }
    return $w;
}

sub add_undef_symbol
{
    my ($sym, $loc) = @_;
    if (exists %usym->{$sym})
    {
	push @{%usym->{$sym}}, $loc;
    }
    else
    {
        %usym->{$sym} = [$loc];
    }
}

sub parse_apart
{
    my $tokenizer = shift;
    my @token = $tokenizer->{next_token}();
    return if !defined @token || @token != 2;
    if ($token[0] eq "=")
    {
        my $w = parse_w_value($tokenizer);
        @token = $tokenizer->{next_token}();
        if (!defined @token || @token != 2 || @token[0] ne "=")
        {
            error("expecting \'=\'");
        }
        
        if (exists %constants->{$w})
        {
            push @{%constants->{$w}->{location}}, $loc;
        }
        else
        {
            %constants->{$w}->{location} = [$loc];
        }
        return 0;
    }
    elsif ($token[0] eq "UNDEF-SYMBOL" || $token[0] eq "FORWARD-REF")
    {
        add_undef_symbol($token[1], $loc);
        return 0;
    }
    elsif ($token[0] eq "SYMBOL" || $token[0] eq "BACKWARD-REF" || $token[0] eq "*"
           || $token[0] eq "INTEGER" || $token[0] eq '-' || $token[0] eq '+')
    {
        $tokenizer->{unget}(@token);
        return parse_expr($tokenizer);
    }
    else
    {
        $tokenizer->{unget}(@token);
    }
}

sub parse_ipart
{
    my $tokenizer = shift;
    my @token = $tokenizer->{next_token}();
    return if !defined @token || @token != 2;
    if ($token[0] eq ",")
    {
        return parse_expr($tokenizer);
    }
    else
    {
        $tokenizer->{unget}(@token);
    }
    return 0;
}

sub parse_fpart
{
    my $tokenizer = shift;
    my @token = $tokenizer->{next_token}();
    return if !defined @token || @token != 2;
    if ($token[0] eq "(")
    {
        my $f = parse_expr($tokenizer);
        @token = $tokenizer->{next_token}();
        if (!defined @token  || @token != 2 || $token[0] ne ")")
        {
            error("expecting \')\'");
        }
        return $f;
    }
    else
    {
        $tokenizer->{unget}(@token);
        return undef;
    }
}

sub parse_operand
{
    my $tokenizer = shift;
    my $a = parse_apart($tokenizer);
    my $i = parse_ipart($tokenizer);
    my $f = parse_fpart($tokenizer);
    $a = 0 if !defined $a;
    $i = 0 if !defined $i;
    return ($a, $i, $f);
}

sub chars_to_word
{
    my ($s) = @_;
    my $w = 0;
    for (my $i = 0; $i < 5; $i++)
    {
        $w = $w * $bytesize + char_to_code(substr $s, $i, 1);
    }
    return $w;
}

sub char_to_code 
{ 
    my ($ch) = @_;
    return index($charset, $ch); 
}

sub code_to_char 
{ 
    return undef if $_[0] < 0 || $_[0] >= length($charset);
    return substr($charset, $_[0], 1);
}

sub signof { return @_[0] >= 0 ? 1 : -1; }

sub usage
{
    print STDERR "Usage: perl mixasm.pl <source-file>\n";
    exit(-1);
}

__END__

=head1 SYNOPSIS

    perl mixasm.pl <inputfile>

=head1 DESCRIPTION


=head1 OUTPUT

=over 4

=item file dot crd

A file contains card deck produced by assembler. 
Each line is regarded as a card, holding no more than 80 characters.
For example, the content of C<primes.crd>:

    DATA 101000000000002
    DATA 5199501031018470001611333000219642003200942250321184086
    DATA 120240000002035
    DATA 320490000002010000000049I0000000003
    CODE 730000000001187053739552905376576740000262193015702869807906264090000524338
    CODE 730070000524467000000017600000083750025964868078800497500259649200000262195
    CODE 730140788529575078721847105229784690533463220001310738A01313341970025973064
    CODE 730210000000069000001718300002622600013107317079167505300000175730006308172
    CODE 2302807914127810000000133
    TRANS03000

This file serves as input to the loader of simulator C<mixsim.pl>. 
Columns 1-5 are ignored. The C<DATA>, C<CODE>, and C<TRANS> are there only for
documenting the type of each card.
Column 6 is the number of consecutive words on this card.
Columns 7-10 is the location of word 1, which is always greater than 100, so it
does not overlay the loading router.
Columns 11-20, 21-30, ..., 71-80 are the words to be loaded.

For example, a card which has

    DATA 320490000002010000000049I0000000003

should cause the following information to be loaded:

    2049: + 0000002010
    2050: - 0000000499
    2051: + 0000000003

You may have noticed that the word "000000049I" is loaded as "-499".
That is a tricky way to punch sign of word on card without using additional characters.

    SPACE 0
      A   1
      B   2
      C   3
      D   4
      E   5
      F   6
      G   7
      H   8
      I   9

If the least significant digit is among the special characters above,
the sign of word it represents is negative.

If the column 6 is `0', then this card is a transfer card. That means, 
after the loader reads this card, MIX jumps to location punched
in columns 7-10.

=item file dot lst

MIXAL program listing, 
with the assembled words and source lines sitting side by side.

=back

=head1 MIXAL SYNTAX

General rules:

    1. No tabs allowed.
    2. Lines started with star will be ignored.
    3. Empty lines are ignored.

Source line can be separated into four fields:

    Columns  1-10  LOC(location) field
    Columns 12-15  OP field
    Columns 17-80  ADDRESS field and optional remarks

Whitespaces are important in MIXAL programs.
They are used for separating label from op, and op from operands.
There should be no spaces in address field. 

    CHANGEM   ENT2  0,3    => OK
    CHANGEM   ENT2  0, 3   => ERROR

